home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / share / autoconf / Autom4te / General.pm < prev    next >
Text File  |  2006-04-25  |  9KB  |  431 lines
  1. # autoconf -- create `configure' using m4 macros
  2. # Copyright (C) 2001, 2002, 2003  Free Software Foundation, Inc.
  3.  
  4. # This program is free software; you can redistribute it and/or modify
  5. # it under the terms of the GNU General Public License as published by
  6. # the Free Software Foundation; either version 2, or (at your option)
  7. # any later version.
  8.  
  9. # This program is distributed in the hope that it will be useful,
  10. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. # GNU General Public License for more details.
  13.  
  14. # You should have received a copy of the GNU General Public License
  15. # along with this program; if not, write to the Free Software
  16. # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  17. # 02111-1307, USA.
  18.  
  19. package Autom4te::General;
  20.  
  21. =head1 NAME
  22.  
  23. Autom4te::General - general support functions for Autoconf and Automake
  24.  
  25. =head1 SYNOPSIS
  26.  
  27.   use Autom4te::General
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. This perl module provides various general purpose support functions
  32. used in several executables of the Autoconf and Automake packages.
  33.  
  34. =cut
  35.  
  36. use 5.005_03;
  37. use Exporter;
  38. use Autom4te::ChannelDefs;
  39. use Autom4te::Channels;
  40. use File::Basename;
  41. use File::stat;
  42. use IO::File;
  43. use Carp;
  44. use strict;
  45.  
  46. use vars qw (@ISA @EXPORT);
  47.  
  48. @ISA = qw (Exporter);
  49.  
  50. # Variables we define and export.
  51. my @export_vars =
  52.   qw ($debug $force $help $me $tmp $verbose $version);
  53.  
  54. # Functions we define and export.
  55. my @export_subs =
  56.   qw (&debug
  57.       &getopt &mktmpdir
  58.       &uniq);
  59.  
  60. # Functions we forward (coming from modules we use).
  61. my @export_forward_subs =
  62.   qw (&basename &dirname &fileparse);
  63.  
  64. @EXPORT = (@export_vars, @export_subs, @export_forward_subs);
  65.  
  66.  
  67. # Variable we share with the main package.  Be sure to have a single
  68. # copy of them: using `my' together with multiple inclusion of this
  69. # package would introduce several copies.
  70.  
  71. =head2 Global Variables
  72.  
  73. =over 4
  74.  
  75. =item C<$debug>
  76.  
  77. Set this variable to 1 if debug messages should be enabled.  Debug
  78. messages are meant for developpers only, or when tracking down an
  79. incorrect execution.
  80.  
  81. =cut
  82.  
  83. use vars qw ($debug);
  84. $debug = 0;
  85.  
  86. =item C<$force>
  87.  
  88. Set this variable to 1 to recreate all the files, or to consider all
  89. the output files are obsolete.
  90.  
  91. =cut
  92.  
  93. use vars qw ($force);
  94. $force = undef;
  95.  
  96. =item C<$help>
  97.  
  98. Set to the help message associated to the option C<--help>.
  99.  
  100. =cut
  101.  
  102. use vars qw ($help);
  103. $help = undef;
  104.  
  105. =item C<$me>
  106.  
  107. The name of this application, as should be used in diagostic messages.
  108.  
  109. =cut
  110.  
  111. use vars qw ($me);
  112. $me = basename ($0);
  113.  
  114. =item C<$tmp>
  115.  
  116. The name of the temporary directory created by C<mktmpdir>.  Left
  117. C<undef> otherwise.
  118.  
  119. =cut
  120.  
  121. # Our tmp dir.
  122. use vars qw ($tmp);
  123. $tmp = undef;
  124.  
  125. =item C<$verbose>
  126.  
  127. Enable verbosity messages.  These messages are meant for ordinary
  128. users, and typically make explicit the steps being performed.
  129.  
  130. =cut
  131.  
  132. use vars qw ($verbose);
  133. $verbose = 0;
  134.  
  135. =item C<$version>
  136.  
  137. Set to the version message associated to the option C<--version>.
  138.  
  139. =cut
  140.  
  141. use vars qw ($version);
  142. $version = undef;
  143.  
  144. =back
  145.  
  146. =cut
  147.  
  148.  
  149.  
  150. ## ----- ##
  151. ## END.  ##
  152. ## ----- ##
  153.  
  154. =head2 Functions
  155.  
  156. =over 4
  157.  
  158. =item C<END>
  159.  
  160. Filter Perl's exit codes, delete any temporary directory (unless
  161. C<$debug>), and exit nonzero whenever closing C<STDOUT> fails.
  162.  
  163. =cut
  164.  
  165. # END
  166. # ---
  167. sub END
  168. {
  169.   # $? contains the exit status we will return.
  170.   # It was set using one of the following ways:
  171.   #
  172.   #  1) normal termination
  173.   #     this sets $? = 0
  174.   #  2) calling `exit (n)'
  175.   #     this sets $? = n
  176.   #  3) calling die or friends (croak, confess...):
  177.   #     a) when $! is non-0
  178.   #        this set $? = $!
  179.   #     b) when $! is 0 but $? is not
  180.   #        this sets $? = ($? >> 8)   (i.e., the exit code of the
  181.   #        last program executed)
  182.   #     c) when both $! and $? are 0
  183.   #        this sets $? = 255
  184.   #
  185.   # Cases 1), 2), and 3b) are fine, but we prefer $? = 1 for 3a) and 3c).
  186.   $? = 1 if ($! && $! == $?) || $? == 255;
  187.   # (Note that we cannot safely distinguish calls to `exit (n)'
  188.   # from calls to die when `$! = n'.  It's not big deal because
  189.   # we only call `exit (0)' or `exit (1)'.)
  190.  
  191.   if (!$debug && defined $tmp && -d $tmp)
  192.     {
  193.       if (<$tmp/*>)
  194.     {
  195.       if (! unlink <$tmp/*>)
  196.         {
  197.           print STDERR "$me: cannot empty $tmp: $!\n";
  198.           $? = 1;
  199.           return;
  200.         }
  201.     }
  202.       if (! rmdir $tmp)
  203.     {
  204.       print STDERR "$me: cannot remove $tmp: $!\n";
  205.       $? = 1;
  206.       return;
  207.     }
  208.     }
  209.  
  210.   # This is required if the code might send any output to stdout
  211.   # E.g., even --version or --help.  So it's best to do it unconditionally.
  212.   if (! close STDOUT)
  213.     {
  214.       print STDERR "$me: closing standard output: $!\n";
  215.       $? = 1;
  216.       return;
  217.     }
  218. }
  219.  
  220.  
  221. ## ----------- ##
  222. ## Functions.  ##
  223. ## ----------- ##
  224.  
  225.  
  226. =item C<debug (@message)>
  227.  
  228. If the debug mode is enabled (C<$debug> and C<$verbose>), report the
  229. C<@message> on C<STDERR>, signed with the name of the program.
  230.  
  231. =cut
  232.  
  233. # &debug(@MESSAGE)
  234. # ----------------
  235. # Messages displayed only if $DEBUG and $VERBOSE.
  236. sub debug (@)
  237. {
  238.   print STDERR "$me: ", @_, "\n"
  239.     if $verbose && $debug;
  240. }
  241.  
  242.  
  243. =item C<getopt (%option)>
  244.  
  245. Wrapper around C<Getopt::Long>.  In addition to the user C<option>s,
  246. support C<-h>/C<--help>, C<-V>/C<--version>, C<-v>/C<--verbose>,
  247. C<-d>/C<--debug>, C<-f>/C<--force>.  Conform to the GNU Coding
  248. Standards for error messages.  Try to work around a weird behavior
  249. from C<Getopt::Long> to preserve C<-> as an C<@ARGV> instead of
  250. rejecting it as a broken option.
  251.  
  252. =cut
  253.  
  254. # getopt (%OPTION)
  255. # ----------------
  256. # Handle the %OPTION, plus all the common options.
  257. # Work around Getopt bugs wrt `-'.
  258. sub getopt (%)
  259. {
  260.   my (%option) = @_;
  261.   use Getopt::Long;
  262.  
  263.   # F*k.  Getopt seems bogus and dies when given `-' with `bundling'.
  264.   # If fixed some day, use this: '' => sub { push @ARGV, "-" }
  265.   my $stdin = grep /^-$/, @ARGV;
  266.   @ARGV = grep !/^-$/, @ARGV;
  267.   %option = ("h|help"     => sub { print $help; exit 0 },
  268.          "V|version"  => sub { print $version; exit 0 },
  269.  
  270.          "v|verbose"    => \$verbose,
  271.          "d|debug"      => \$debug,
  272.          'f|force'      => \$force,
  273.  
  274.          # User options last, so that they have precedence.
  275.          %option);
  276.   Getopt::Long::Configure ("bundling", "pass_through");
  277.   GetOptions (%option)
  278.     or exit 1;
  279.  
  280.   foreach (grep { /^-./ } @ARGV)
  281.     {
  282.       print STDERR "$0: unrecognized option `$_'\n";
  283.       print STDERR "Try `$0 --help' for more information.\n";
  284.       exit (1);
  285.     }
  286.  
  287.   push @ARGV, '-'
  288.     if $stdin;
  289.  
  290.   setup_channel 'note', silent => !$verbose;
  291.   setup_channel 'verb', silent => !$verbose;
  292. }
  293.  
  294.  
  295. =item C<mktmpdir ($signature)>
  296.  
  297. Create a temporary directory which name is based on C<$signature>.
  298. Store its name in C<$tmp>.  C<END> is in charge of removing it, unless
  299. C<$debug>.
  300.  
  301. =cut
  302.  
  303. # mktmpdir ($SIGNATURE)
  304. # ---------------------
  305. sub mktmpdir ($)
  306. {
  307.   my ($signature) = @_;
  308.   my $TMPDIR = $ENV{'TMPDIR'} || '/tmp';
  309.  
  310.   # If mktemp supports dirs, use it.
  311.   $tmp = `(umask 077 &&
  312.        mktemp -d -q "$TMPDIR/${signature}XXXXXX") 2>/dev/null`;
  313.   chomp $tmp;
  314.  
  315.   if (!$tmp || ! -d $tmp)
  316.     {
  317.       $tmp = "$TMPDIR/$signature" . int (rand 10000) . ".$$";
  318.       mkdir $tmp, 0700
  319.     or croak "$me: cannot create $tmp: $!\n";
  320.     }
  321.  
  322.   print STDERR "$me:$$: working in $tmp\n"
  323.     if $debug;
  324. }
  325.  
  326.  
  327. =item C<uniq (@list)>
  328.  
  329. Return C<@list> with no duplicates, keeping only the first
  330. occurrences.
  331.  
  332. =cut
  333.  
  334. # @RES
  335. # uniq (@LIST)
  336. # ------------
  337. sub uniq (@)
  338. {
  339.   my @res = ();
  340.   my %seen = ();
  341.   foreach my $item (@_)
  342.     {
  343.       if (! exists $seen{$item})
  344.     {
  345.       $seen{$item} = 1;
  346.       push (@res, $item);
  347.     }
  348.     }
  349.   return wantarray ? @res : "@res";
  350. }
  351.  
  352.  
  353. =item C<handle_exec_errors ($command)>
  354.  
  355. Display an error message for C<$command>, based on the content of
  356. C<$?> and C<$!>.
  357.  
  358. =cut
  359.  
  360.  
  361. # handle_exec_errors ($COMMAND)
  362. # -----------------------------
  363. sub handle_exec_errors ($)
  364. {
  365.   my ($command) = @_;
  366.  
  367.   $command = (split (' ', $command))[0];
  368.   if ($!)
  369.     {
  370.       error "failed to run $command: $!";
  371.     }
  372.   else
  373.     {
  374.       use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
  375.  
  376.       if (WIFEXITED ($?))
  377.     {
  378.       my $status = WEXITSTATUS ($?);
  379.       # WIFEXITED and WEXITSTATUS can alter $!, reset it so that
  380.       # error() actually propagates the command's exit status, not $!.
  381.       $! = 0;
  382.       error "$command failed with exit status: $status";
  383.     }
  384.       elsif (WIFSIGNALED ($?))
  385.     {
  386.       my $signal = WTERMSIG ($?);
  387.       # In this case we prefer to exit with status 1.
  388.       $! = 1;
  389.       error "$command terminated by signal: $signal";
  390.     }
  391.       else
  392.     {
  393.       error "$command exited abnormally";
  394.     }
  395.     }
  396. }
  397.  
  398. =back
  399.  
  400. =head1 SEE ALSO
  401.  
  402. L<Autom4te::XFile>
  403.  
  404. =head1 HISTORY
  405.  
  406. Written by Alexandre Duret-Lutz E<lt>F<adl@gnu.org>E<gt> and Akim
  407. Demaille E<lt>F<akim@freefriends.org>E<gt>.
  408.  
  409. =cut
  410.  
  411.  
  412.  
  413. 1; # for require
  414.  
  415. ### Setup "GNU" style for perl-mode and cperl-mode.
  416. ## Local Variables:
  417. ## perl-indent-level: 2
  418. ## perl-continued-statement-offset: 2
  419. ## perl-continued-brace-offset: 0
  420. ## perl-brace-offset: 0
  421. ## perl-brace-imaginary-offset: 0
  422. ## perl-label-offset: -2
  423. ## cperl-indent-level: 2
  424. ## cperl-brace-offset: 0
  425. ## cperl-continued-brace-offset: 0
  426. ## cperl-label-offset: -2
  427. ## cperl-extra-newline-before-brace: t
  428. ## cperl-merge-trailing-else: nil
  429. ## cperl-continued-statement-offset: 2
  430. ## End:
  431.